Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/wlpprchg/wallchng.frm

Text File | 1995-09-06 | 9KB | 348 lines

VERSION 2.00
Begin Form WallChng
   BackColor       =   &H00000000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Wall Change"
   ClientHeight    =   2325
   ClientLeft      =   3120
   ClientTop       =   2655
   ClientWidth     =   2610
   Height          =   2730
   Icon            =   WALLCHNG.FRX:0000
   Left            =   3060
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   Picture         =   WALLCHNG.FRX:0302
   ScaleHeight     =   2325
   ScaleWidth      =   2610
   Top             =   2310
   Width           =   2730
   Begin CommandButton Quit
      Caption         =   "Quit"
      Height          =   375
      Left            =   1416
      TabIndex        =   6
      Top             =   1068
      Width           =   735
   End
   Begin CommandButton About
      Caption         =   "About"
      Height          =   375
      Left            =   372
      TabIndex        =   5
      Top             =   1068
      Width           =   735
   End
   Begin ComboBox Combo1
      BackColor       =   &H000000FF&
      ForeColor       =   &H00FF0000&
      Height          =   300
      Left            =   510
      TabIndex        =   0
      Text            =   "Combo1"
      Top             =   570
      Width           =   1530
   End
   Begin Timer Timer5
      Interval        =   1315
      Left            =   1440
      Top             =   0
   End
   Begin Timer Timer4
      Interval        =   1210
      Left            =   1080
      Top             =   15
   End
   Begin Timer Timer3
      Interval        =   1105
      Left            =   705
      Top             =   0
   End
   Begin Timer Timer2
      Interval        =   1000
      Left            =   375
      Top             =   0
   End
   Begin Timer Timer1
      Left            =   0
      Top             =   0
   End
   Begin Label icon4
      Caption         =   "icon4"
      DragIcon        =   WALLCHNG.FRX:0AB2
      Height          =   192
      Left            =   2004
      TabIndex        =   4
      Top             =   720
      Visible         =   0   'False
      Width           =   576
   End
   Begin Label icon3
      Caption         =   "icon3"
      DragIcon        =   WALLCHNG.FRX:0DB4
      Height          =   216
      Left            =   1992
      TabIndex        =   3
      Top             =   468
      Visible         =   0   'False
      Width           =   588
   End
   Begin Label icon2
      Caption         =   "icon2"
      DragIcon        =   WALLCHNG.FRX:10B6
      Height          =   216
      Left            =   1992
      TabIndex        =   2
      Top             =   240
      Visible         =   0   'False
      Width           =   588
   End
   Begin Label icon1
      Caption         =   "icon1"
      DragIcon        =   WALLCHNG.FRX:13B8
      Height          =   192
      Left            =   2028
      TabIndex        =   1
      Top             =   0
      Visible         =   0   'False
      Width           =   540
   End
End
DefInt A-Z
Declare Sub SystemParametersInfo Lib "User" (ByVal wAction%, ByVal wParam%, lParam As Any, ByVal fWinIni%)
Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags As Integer) As Long
Declare Function GetModuleHandle Lib "Kernel" (ByVal ModName$)
Declare Function GetHeapSpaces& Lib "Kernel" (ByVal hModule)
Declare Function DiskInfo Lib "DiskInfo.DLL" (ByVal DriveNum%, ByVal DriveInfo%) As Long

Dim WallPaperFile As String
Dim Called As String
Dim CapSwitch As String
Dim timeloop As Integer
Dim mem As String
Dim res As String
Dim disk(3 To 5) As String
Dim tim As String
Dim MyTime As String
Dim OldMyTime As String
Dim Hours As Integer
Dim x As Integer

Sub About_Click ()
    ret$ = Chr$(13) + Chr$(10)
    title$ = "About"
    msg$ = "   Wallpaper Changer - Version 8/92" + ret$ + ret$
    msg$ = msg$ + "        By Tim Hitchings (73637,66)" + ret$ + ret$
    msg$ = msg$ + "Special Thanks:  " + ret$
    msg$ = msg$ + "╖ The Waite Group's Visual Basic How-To" + ret$
    msg$ = msg$ + "╖ Ian Taylor for the DiskInfo.DLL" + ret$
    msg$ = msg$ + "╖ Nelson Ford for VB-Tips"
    MsgBox msg$, 0, title$
End Sub

Sub combo1_click ()
  If combo1.text = "30 Minutes" Then
    timer1.interval = 60000
    timeloop = 30
  ElseIf combo1.text = " 5 Minutes" Then
    timer1.interval = 60000
    timeloop = 5
  ElseIf combo1.text = " 1 Minute" Then
    timer1.interval = 60000
  ElseIf combo1.text = "30 Seconds" Then
    timer1.interval = 30000
  ElseIf combo1.text = "10 Seconds" Then
    timer1.interval = 10000
  ElseIf combo1.text = " 1 Second" Then
    timer1.interval = 1000
  ElseIf combo1.text = "PAUSE" Then
    timer1.interval = 0
  End If
  combo1.Refresh
  windowstate = 1
End Sub

Sub DirBMP ()
    Called = "Y"
    Filespec$ = "*.BMP"
    WallPaperFile = Dir$(Filespec$)
    If Len(WallPaperFile) = 0 Then
    title$ = "Fatal Error"
    msg$ = "You must put WALLCHNG.EXE in your WINDOWS DIRECTORY!"
    response% = MsgBox(msg$, 16, title$)
    Unload Wallchng
    End
    End If
End Sub

Sub DirBMP2 ()
    Filespec$ = "*.BMP"
    WallPaperFile = Dir$
    If Len(WallPaperFile) = 0 Then
    DirBMP
    End If
End Sub

Sub Form_Load ()
  combo1.AddItem "PAUSE"
  combo1.AddItem " 1 Second"
  combo1.AddItem "10 Seconds"
  combo1.AddItem "30 Seconds"
  combo1.AddItem " 1 Minute"
  combo1.AddItem " 5 Minutes"
  combo1.AddItem "30 Minutes"
  combo1.text = "30 Minutes"
  timer1.interval = 60000
  timeloop = 30
  windowstate = 1
  ResMemDisk
  Wallchng.caption = mem
  CapSwitch = "1"
End Sub

Function GetFreeResources (ModuleName$)
    rInfo& = GetHeapSpaces&(GetModuleHandle(ModuleName$))
    Totalr& = HiWord&(rInfo&)
    FreeR& = LoWord(rInfo&)
    GetFreeResources = FreeR& * 100 \ Totalr&
End Function


Function HiWord& (LongInt&)
    Temp& = LongInt& \ &H10000
    If Temp& < 0 Then Temp& = Temp& + &H10000
    HiWord& = Temp&
End Function


Function LoWord& (LongInt&)
    Temp& = LongInt& Mod &H10000
    If Temp& < 0 Then Temp& = Temp& + &H10000
    LoWord& = Temp&
End Function


Function Min (P1, P2)
    If P1 < P2 Then Min = P1 Else Min = P2
End Function

Sub Quit_Click ()
    Unload Wallchng
    End
End Sub

Sub ResMemDisk ()
  Static SpaceFree As Long
  x = 3
  SpaceFree = DiskInfo(x, 1)
  Do While SpaceFree <> -1
    disk(x) = Chr$(x + 64) + ": " + Format$((SpaceFree \ 1024) \ 1000) + "M free"
    x = x + 1
    If x > 5 Then
    x = 5
    End If
    SpaceFree = DiskInfo(x, 1)
  Loop
  x = 3
  Static OldFreeSpace As Long, FreeSpace As Long
  FreeSpace = GetFreeSpace(0)
  If OldFreeSpace <> FreeSpace Then
    OldFreeSpace = FreeSpace
    mem = "Free memory: " + Format$((FreeSpace \ 1024) \ 1000) + "M"
  End If

  TFree = Min(GetFreeResources("User"), GetFreeResources("GDI"))
  If TFree <> OldTotal Then
    OldTotal = TFree
    res = "Free resources: " + Format$(TFree, "00") + "%"
  End If

  MyTime = Mid$(Time$, 1, 5)
  If MyTime <> OldMyTime Then
    OldMyTime = MyTime
    Hours = Val(MyTime)
    If Hours > 12 Then Mid$(MyTime, 1, 2) = Str$(Hours - 12)
    tim = "Time:  " + MyTime
  End If
End Sub

Sub timer1_timer ()
    If combo1.text = " 5 Minutes" Then
    timeloop = timeloop - 1
    End If
    If combo1.text = "30 Minutes" Then
    timeloop = timeloop - 1
    End If
    If combo1.text = "30 Minutes" Then
    If timeloop = 0 Then
        If Called = "Y" Then
        DirBMP2
        Else
        DirBMP
        End If
        WallPaper$ = WallPaperFile
        SystemParametersInfo SPI_SETDESKWALLPAPER, 0, ByVal WallPaper$, SPIF_UPDATEINIFILE
        timeloop = 30
    End If
    ElseIf combo1.text = " 5 Minutes" Then
    If timeloop = 0 Then
        If Called = "Y" Then
        DirBMP2
        Else
        DirBMP
        End If
        WallPaper$ = WallPaperFile
        SystemParametersInfo SPI_SETDESKWALLPAPER, 0, ByVal WallPaper$, SPIF_UPDATEINIFILE
        timeloop = 5
    End If
    Else
    If Called = "Y" Then
        DirBMP2
    Else